(SETQ IBASE (ADD1 7)) 


(DEFPROP PRDFNS 
 (NIL !STKLOC
      !TSTLST
      !ASSLST
      !X
      !NR
      !WORRYFLG
      !BNF
      !RULE
      PRDEXP
      OUTBLDINIT
      RTLSTSIZE
      PRODUCE
      UNPRODUCE
      BROKET
      SQBROK
      PRD
      PBLD0
      PBLD1
      STKIFY
      PBLD21
      GETATOM
      ASSOCL
      SUBSTL
      MKLIST
      OUTORDER
      ORDTST2
      WORRY
      TTYPRINT
      TTYPRIN1
      MKRITE
      TST
      VARIABLE
      SPCS
      CONSTLST
      TST2
      TST3
      OTA
      OT1
      OT2
      MKMATCH
      MAGPRE
      STKLST
      MKBLD2
      MKBLD
      OUTMAK1
      MKTST2
      MKTST
      MAKOUTRULE
      OUTMAKE
      MKOP) 
VALUE)

(DEFPROP !STKLOC 
 T 
SPECIAL)

(DEFPROP !TSTLST 
 T 
SPECIAL)

(DEFPROP !ASSLST 
 T 
SPECIAL)

(DEFPROP !X 
 T 
SPECIAL)

(DEFPROP !NR 
 T 
SPECIAL)

(DEFPROP !WORRYFLG 
 (NIL) 
VALUE)

(DEFPROP !WORRYFLG 
 T 
SPECIAL)

(DEFPROP !BNF 
 T 
SPECIAL)

(DEFPROP !RULE 
 T 
SPECIAL)

(DEFPROP PRDEXP 
 (NIL OUTORDER ORDTST2 WORRY OTA OT1 OT2) 
VALUE)

(DEFPROP OUTBLDINIT 
 (LAMBDA NIL (PROG NIL (ARRAY ORDNAM T RTLSTSIZE) (ARRAY ORDNUM T RTLSTSIZE) (ARRAY ORDLST T RTLSTSIZE))) 
EXPR)

(DEFPROP RTLSTSIZE 
 (NIL . 40) 
VALUE)

(DEFPROP PRODUCE 
 (LAMBDA(L)
  (PROG NIL
	(SETQ <LANG>
	      (MAPCAR (FUNCTION
		       (LAMBDA(X)
			(PROG (Y)
			      (SETQ Y (BROKET (CAR X)))
			      (PUTPROP (CAR X) (CADR X) (QUOTE BNF))
			      (PRD (CAR X))
			      (RETURN Y))))
 		      L))
	(SETQ >LANG<
	      (MAPCAR (FUNCTION (LAMBDA (X) (PROG (Y) (SETQ Y (SQBROK (CAR X))) (MAKOUTRULE X Y) (RETURN Y))))
 		      L)))) 
EXPR)

(DEFPROP UNPRODUCE 
 (LAMBDA (L) (MAPCAR (FUNCTION (LAMBDA (X) (LIST X (GET X (QUOTE BNF))))) L)) 
EXPR)

(DEFPROP BROKET 
 (LAMBDA(X)
  (PROG (L) (SETQ L (EXPLODE X)) (RPLACD (LAST L) (QUOTE (>))) (RETURN (READLIST (CONS (QUOTE <) L))))) 
EXPR)

(DEFPROP SQBROK 
 (LAMBDA(X)
  (PROG (L) (SETQ L (EXPLODE X)) (RPLACD (LAST L) (QUOTE (<))) (RETURN (READLIST (CONS (QUOTE >) L))))) 
EXPR)

(DEFPROP PRD 
 (LAMBDA(X)
  (PROG (NR R RL FS)
	(SETQ RL (REVERSE (GET X (QUOTE BNF))))
   L    (COND
	 ((NULL RL) (PUTPROP (BROKET X) (LIST (QUOTE LAMBDA) NIL (PBLD0 X NR R)) (QUOTE EXPR)) (RETURN X)))
	(SETQ FS (CAAR RL))
   L2   (COND ((NULL FS) (GO L3))
	      ((EQ (CAR FS) X) (SETQ R (CONS (CAR RL) R)) (GO L4))
	      ((EQ (CAAR FS) (QUOTE FORMAT)) (SETQ FS (CDR FS)) (GO L2)))
   L3   (SETQ NR (CONS (CAR RL) NR))
   L4   (SETQ RL (CDR RL))
	(GO L))) 
EXPR)

(DEFPROP PBLD0 
 (LAMBDA(LP RPSM LFRC)
  (COND ((NOT LFRC)
	 (LIST (QUOTE NLRR)
	       (LIST (QUOTE QUOTE) LP)
	       (LIST (QUOTE FUNCTION) (LIST (QUOTE LAMBDA) NIL (PBLD1 T RPSM)))))
	(T
	 (LIST (QUOTE LRR)
	       (LIST (QUOTE QUOTE) LP)
	       (LIST (QUOTE FUNCTION) (LIST (QUOTE LAMBDA) NIL (PBLD1 T RPSM)))
	       (LIST (QUOTE FUNCTION) (LIST (QUOTE LAMBDA) (QUOTE (<*>)) (PBLD1 NIL LFRC))))))) 
EXPR)

(DEFPROP PBLD1 
 (LAMBDA(!NR RPSM)
  (CONS (QUOTE COND)
	(APPEND (MAPCAR (FUNCTION (LAMBDA (X) (PBLD21 (NOT !NR) (CAR X) (STKIFY (CADR X) (CAR X))))) RPSM)
		(QUOTE ((*NIL*)))))) 
EXPR)

(DEFPROP STKIFY 
 (LAMBDA(X RTPT)
  (COND ((NULL X) NIL)
	((EQ X (QUOTE *)) (LIST (QUOTE STK) (GETATOM RTPT)))
	((MEMBER X RTPT) (LIST (QUOTE STK) X))
	((ATOM X) (LIST (QUOTE QUOTE) X))
	(T (LIST (QUOTE CONS) (STKIFY (CAR X) RTPT) (STKIFY (CDR X) RTPT))))) 
EXPR)

(DEFPROP PBLD21 
 (LAMBDA(LRR RTPT SEM)
  (PROG (I NRP)
	(SETQ I -1)
	(SETQ RTPT (REVERSE RTPT))
   L    (COND ((NULL RTPT) (GO L2))
	      ((EQ (CAAR RTPT) (QUOTE FORMAT)))
	      (T (SETQ I (ADD1 I))
		 (SETQ NRP (CONS (COND ((ATOM (CAR RTPT)) (NCONS (BROKET (CAR RTPT)))) (T (CAR RTPT))) NRP))
		 (COND ((ATOM (CAR RTPT)) (SETQ SEM (SUBST I (CAR RTPT) SEM))))))
	(SETQ RTPT (CDR RTPT))
	(GO L)
   L2   (COND (LRR (SETQ SEM (SUBST (QUOTE <*>) (LIST (QUOTE STK) I) SEM)) (SETQ NRP (CDR NRP))))
	(RETURN (LIST (CONS (QUOTE AND) NRP) SEM)))) 
EXPR)

(DEFPROP GETATOM 
 (LAMBDA (L) (COND ((ATOM (CAR L)) (CAR L)) (T (GETATOM (CDR L))))) 
EXPR)

(DEFPROP ASSOCL 
 (LAMBDA (X L) (COND ((NULL L) NIL) ((EQUAL X (CAAR L)) (CAR L)) (T (ASSOCL X (CDR L))))) 
EXPR)

(DEFPROP SUBSTL 
 (LAMBDA (L X) (COND ((NULL L) X) (T (SUBSTL (CDR L) (SUBST (CAAR L) (CADAR L) X))))) 
EXPR)

(DEFPROP MKLIST 
 (LAMBDA (X) (COND ((NULL (CDR X)) (CAR X)) (T (CONS (QUOTE LIST) X)))) 
EXPR)

(DEFPROP OUTORDER 
 (LAMBDA(BNF)
  (PROG (I J N !WORRYFLG L)
	(SETQ I 0)
	(FOR X (IN BNF) (DO (PROG NIL (SETQ I (ADD1 I)) (STORE (ORDNAM I) X))))
	(SETQ N I)
   L1   (SETQ !WORRYFLG NIL)
	(FOR I
	     (STEP 1 1 N)
	     (DO
	      (STORE (ORDLST I)
		     (FOR J
			  (STEP 1 1 N)
			  (COLLECT J)
			  (UNLESS
			   (OR (EQ I J)
			       (NULL (ORDNAM J))
			       (NOT (SPCS (MKRITE (ORDNAM I)) (MKRITE (ORDNAM J)) NIL)))))))
	     (UNLESS (NULL (ORDNAM I))))
	(FOR I (STEP 1 1 N) (DO (STORE (ORDNUM I) 0)))
	(FOR I (STEP 1 1 N) (DO (FOR J (IN (ORDLST I)) (DO (STORE (ORDNUM J) -1)))))
	(FOR I (STEP 1 1 N) (UNLESS (NOT (ZEROP (ORDNUM I)))) (DO (ORDTST2 (ORDLST I) (NCONS I) 1)))
	(WORRY (FOR I (STEP 1 1 N) (COLLECT I) (UNLESS (NOT (EQUAL (ORDNUM I) -1)))))
	(COND (!WORRYFLG (GO L1)))
	(SETQ L NIL)
	(FOR D
	     (STEP N -1 0)
	     (DO
	      (FOR I
		   (STEP N -1 1)
		   (DO (COND ((AND (EQ (ORDNUM I) D) (ORDNAM I)) (SETQ L (CONS (ORDNAM I) L))))))))
	(RETURN L))) 
EXPR)

(DEFPROP ORDTST2 
 (LAMBDA(L PATH N)
  (FOR X
       (IN L)
       (DO
	(PROG2 (COND ((MEMQ X PATH) (WORRY PATH)) ((LESSP (ORDNUM X) N) (STORE (ORDNUM X) N)))
	       (ORDTST2 (ORDLST X) (CONS X PATH) (ADD1 N)))))) 
EXPR)

(DEFPROP WORRY 
 (LAMBDA(L)
  (PROG NIL
	(COND ((NULL L) (RETURN NIL)))
	(TTYPRINT (CONS !RULE (QUOTE (HAS OUTPUT AMBIGUITY; YOUR CHOICES ARE:))))
	(FOR I (IN L) (DO (PROG2 (TTYPRINT I) (TTYPRIN1 (CAR (ORDNAM I))))))
	(TTYPRINT (QUOTE (TYPE LIST OF NUMBERS OF LINES TO DELETE)))
	(FOR I (IN (READ)) (DO (STORE (ORDNAM I) NIL)))
	(SETQ !WORRYFLG T))) 
EXPR)

(DEFPROP TTYPRINT 
 (LAMBDA (X) (PROG (C) (SETQ C (OUTC NIL NIL)) (PRINT X) (OUTC C NIL))) 
EXPR)

(DEFPROP TTYPRIN1 
 (LAMBDA (X) (PROG (C) (SETQ C (OUTC NIL NIL)) (PRIN1 X) (OUTC C NIL))) 
EXPR)

(DEFPROP MKRITE 
 (LAMBDA (L) (COND ((EQ (CADR L) (QUOTE *)) (GETATOM (CAR L))) (T (CADR L)))) 
EXPR)

(DEFPROP TST 
 (LAMBDA (F X) (PROG2 (SETQ %SPDL (LIST X)) (F 0))) 
EXPR)

(DEFPROP VARIABLE 
 (LAMBDA (X) (COND ((NUMBERP X) NIL) ((GET X (QUOTE BNF))) ((MEMQ X (QUOTE (ID NUMBER ATOM CHAR)))))) 
EXPR)

(DEFPROP SPCS 
 (LAMBDA(X Y PATH)
  (COND ((EQ X Y))
	((NULL X))
	((AND (MEMQ Y (QUOTE (ID NUMBER ATOM))) (NOT (VARIABLE X))))
	((AND (ATOM Y) (VARIABLE Y) (NOT (MEMQ Y PATH)))
	 (PROG (BNF)
	       (SETQ BNF (GET Y (QUOTE BNF)))
 	  L    (COND ((NULL BNF) (RETURN NIL))
		     ((SPCS X (MKRITE (CAR BNF)) (CONS Y PATH)) (RETURN T))
		     (T (SETQ BNF (CDR BNF)) (GO L)))))
	((AND (NOT (ATOM Y)) (NOT (ATOM X)) (SPCS (CAR X) (CAR Y) NIL) (SPCS (CDR X) (CDR Y) NIL))))) 
EXPR)

(DEFPROP CONSTLST 
 (NIL T 0 1) 
VALUE)

(DEFPROP TST2 
 (LAMBDA (L) (MAPC (FUNCTION TST3) L)) 
EXPR)

(DEFPROP TST3 
 (LAMBDA(R)
  (PROG (!BNF A B C)
	(PRINT R)
	(SETQ !BNF (GET R (QUOTE BNF)))
	(MAPC (FUNCTION
	       (LAMBDA(!X)
		(MAPC (FUNCTION
		       (LAMBDA(Y)
			(COND ((EQ (CADR !X) (CADR Y)))
			      ((SPCS (CADR !X) (CADR Y) NIL) (TERPRI)
							     (TYO 11)
							     (PRIN1 (CADR !X))
							     (TYO 11)
							     (PRIN1 (MKRITE Y))))))
 		      !BNF)))
 	      !BNF))) 
EXPR)

(DEFPROP OTA 
 (LAMBDA(L)
  (FOR RULE
       (IN L)
       (DO
	(PROG (Y)
	      (TERPRI)
	      (TERPRI)
	      (PRINT RULE)
	      (SETQ Y (OUTORDER (GET RULE (QUOTE BNF))))
	      (OT1 (LENGTH (GET RULE (QUOTE BNF))))
	      (TERPRI)
	      (OT2 Y))))) 
EXPR)

(DEFPROP OT1 
 (LAMBDA(N)
  (FOR I
       (STEP 1 1 N)
       (UNLESS (NULL (ORDNAM I)))
       (DO (PROG2 (PRINT I) (PRIN1 (LIST (ORDNUM I) (ORDLST I) (MKRITE (ORDNAM I)))))))) 
EXPR)

(DEFPROP OT2 
 (LAMBDA (L) (FOR X (IN L) (DO (PRINT (MKRITE X))))) 
EXPR)

(DEFPROP MKMATCH 
 (LAMBDA(SEM)
  (COND ((AND (ATOM SEM) (MEMQ SEM !BNF)) (QUOTE *))
	((ATOM SEM) SEM)
	(T (CONS (MKMATCH (CAR SEM)) (MKMATCH (CDR SEM)))))) 
EXPR)

(DEFPROP MAGPRE 
 (LAMBDA (X) X) 
EXPR)

(DEFPROP STKLST 
 (NIL (0 STK0) (1 STK1) (2 STK2) (3 STK3) (4 STK4) (5 STK5) (6 STK6) (7 STK7)) 
VALUE)

(DEFPROP MKBLD2 
 (LAMBDA(X)
  (COND ((AND (ATOM X) (NULL !ASSLST)) (QUOTE (STK1)))
	((ATOM X) (CDR (ASSOC (CDR (ASSOC X !ASSLST)) STKLST)))
	((MEMQ (CAR X) (QUOTE (CH QCH))) (LIST (QUOTE QUOTE) (CONS (QUOTE :CH) (CDR X))))
	(T (LIST (QUOTE QUOTE) (CADR X))))) 
EXPR)

(DEFPROP MKBLD 
 (LAMBDA(BNF)
  (COND ((NULL BNF) (QUOTE FOOBAZ))
	((NULL (CDR BNF)) (MKBLD2 (CAR BNF)))
	(T (CONS (QUOTE LIST) (MAPCAR (FUNCTION MKBLD2) BNF))))) 
EXPR)

(DEFPROP OUTMAK1 
 (LAMBDA(!BNF SEM)
  (PROG (!ASSLST)
	(RETURN
	 (LIST (COND ((EQ SEM (QUOTE *)) (LIST (SQBROK (GETATOM !BNF)) 1))
		     ((AND (ATOM SEM) (MEMQ SEM !BNF)) (LIST (SQBROK SEM) 1))
		     ((ATOM SEM) (LIST (QUOTE EQ) (LIST (QUOTE QUOTE) SEM) (QUOTE (STK1))))
		     (T
		      (CONS (QUOTE AND)
			    (CONS (LIST (QUOTE MATCH) (LIST (QUOTE QUOTE) (MKMATCH SEM))) (MKTST SEM)))))
	       (MKBLD !BNF))))) 
EXPR)

(DEFPROP MKTST2 
 (LAMBDA(SEM)
  (COND ((NULL SEM))
	((AND (ATOM SEM) (MEMQ SEM !BNF)) (SETQ !TSTLST (CONS (LIST (SQBROK SEM) !STKLOC) !TSTLST))
					  (SETQ !ASSLST (CONS (CONS SEM !STKLOC) !ASSLST))
					  (SETQ !STKLOC (ADD1 !STKLOC)))
	((ATOM SEM))
	(T (MKTST2 (CDR SEM)) (MKTST2 (CAR SEM))))) 
EXPR)

(DEFPROP MKTST 
 (LAMBDA (SEM) (PROG (!TSTLST !STKLOC) (SETQ !STKLOC 0) (MKTST2 SEM) (RETURN !TSTLST))) 
EXPR)

(DEFPROP MAKOUTRULE 
 (LAMBDA(BNF !RULE)
  (PUTPROP !RULE
	   (LIST (QUOTE LAMBDA)
		 (QUOTE (%N))
		 (LIST (QUOTE OUTRUL)
		       (QUOTE %N)
		       (LIST (QUOTE FUNCTION)
			     (LIST (QUOTE LAMBDA)
 				   NIL
				   (CONS (QUOTE COND)
					 (MAGPRE (MAPCAR (FUNCTION OUTMAKE) (OUTORDER (CADR BNF)))))))))
	   (QUOTE EXPR))) 
EXPR)

(DEFPROP OUTMAKE 
 (LAMBDA (L) (OUTMAK1 (CAR L) (CADR L))) 
EXPR)

(DEFPROP MKOP 
 (LAMBDA (OP L) (COND ((NULL L)) ((NULL (CDR L)) (CAR L)) (T (CONS OP L)))) 
EXPR)